home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The Original Shareware 1.1
/
The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso
/
19
/
madtrb11.zip
/
DOS2IO-3.INC
< prev
next >
Wrap
Text File
|
1985-08-17
|
21KB
|
811 lines
(*
Dos2io-3.inc
Dedicated to the public domain.
-- Cole Brecheen
17 August 1985
*)
{$V-} {Relaxes type checking on string parameters.}
{$U-,C-}{Enables keyboard buffering.}
PROCEDURE SetPtrFromEnd( FileHandle: INTEGER;
OffSetFromEnd: REAL );
LABEL EndProcedure;
VAR
TmpPtr : BufferPtr;
rgstr : RegPack;
lngthnum : REAL;
segnum : INTEGER;
BEGIN {SetPtrFromEnd}
lngthnum := FileLength( FileHandle );
IF lngthnum = 0
THEN GOTO EndProcedure;
WITH rgstr DO BEGIN
a.h := $42; {command to move file read/write pointer}
a.l := 0;
{Zero in a.l means that pointer moves to offset bytes
from the beginnning of the file.}
b.x := FileHandle;
RealToSegmented( lngthnum + OffSetFromEnd, c.x, d.x );
msdos( rgstr );
IF FlaggedError( flags )
THEN BEGIN { writeln('setptrfromend error'); } {diag}
PrintMessage( MessageType( a.x ) );
END;
END; {WITH rgstr}
CheckInitialization;
{From here down we're flushing any buffer that
corresponds with this filehandle.}
IF BufLstBase = nil
THEN GOTO EndProcedure;
TmpPtr := BufLstBase;
WHILE (TmpPtr^.next <> nil)
and
(TmpPtr^.handle <> FileHandle) DO TmpPtr := TmpPtr^.next;
IF TmpPtr^.handle = FileHandle
THEN tmpPtr^.ndx := BufSize + 1;
EndProcedure:
END; {SetPtrFromEnd}
PROCEDURE SetPtrFromStart( FileHandle: INTEGER;
OffSetFromStart : REAL );
LABEL
EndProcedure;
VAR
TmpPtr : BufferPtr;
rgstr : RegPack;
BEGIN {SetPtrFromStart}
WITH rgstr DO BEGIN
a.h := $42;
{command to move file read/write pointer}
a.l := 0;
{moves pointer to offset bytes from the beginnning of the
file}
b.x := FileHandle;
RealToSegmented( OffSetFromStart, c.x, d.x );
msdos( rgstr );
IF FlaggedError( flags )
THEN BEGIN { writeln('setptrfromstart error'); } {diag}
PrintMessage( MessageType( a.x ) );
END;
END; {WITH rgstr}
CheckInitialization;
IF BufLstBase = nil
THEN GOTO EndProcedure;
TmpPtr := BufLstBase;
WHILE (TmpPtr^.next <> nil)
and
(TmpPtr^.handle <> FileHandle) DO TmpPtr := TmpPtr^.next;
IF TmpPtr^.handle = FileHandle
THEN tmpPtr^.ndx := BufSize + 1;
EndProcedure:
END; {SetPtrFromStart}
FUNCTION BytesToWord( lobyte, hibyte: INTEGER ): INTEGER;
{Takes two bytes and stores them in a single word. The
last byte in the parameter list is most significant.}
BEGIN {BytesToWord}
hibyte := swap( hibyte );
{Reverses the order of the two bytes in hibyte.}
BytesToWord := lobyte OR hibyte;
{OR does bitwise addition in this language.}
END; {BytesToWord}
PROCEDURE BitRangeToInt( TheSet: BitSet;
LowBit, HighBit: INTEGER;
VAR answer: INTEGER );
{BitRangeToInt lets us specify the bits that store the
value in which we're interested, and it loads that value
into the last parameter in the list.}
FUNCTION power(x,n:INTEGER): INTEGER;
{Returns x raised to the nth power.}
VAR w,z,i: INTEGER;
BEGIN
w := x; i := n;
z := 1;
WHILE i <> 0 DO
BEGIN
IF ODD(i) THEN z := z*w;
i := i DIV 2;
IF i <> 0
THEN w := w*w;
END;
power := z;
END; {power}
VAR
tmp: RECORD
CASE BOOLEAN of
true: ( IntForm : INTEGER );
false:( SetForm : BitSet );
END;
cnt : INTEGER;
BEGIN {BitRangeToInt}
tmp.SetForm := TheSet;
{Bit 15 is most significant.}
answer := 0;
FOR cnt := LowBit TO HighBit DO
BEGIN
IF cnt IN tmp.SetForm
THEN answer := answer + power( 2, cnt - LowBit );
END;
END; {BitRangeToInt}
PROCEDURE IntegerToDate( TheInt: INTEGER;
VAR month, day, year: INTEGER );
VAR
TheSet : BitSet;
BEGIN {IntegerToDate}
IntegerToBitSet( TheInt, TheSet );
BitRangeToInt( TheSet, 0, 4, day );
BitRangeToInt( TheSet, 5, 8, month );
BitRangeToInt( TheSet, 9, 15, year );
year := year + 80;
END; {IntegerToDate}
FUNCTION DateToInteger( month, day, year: INTEGER ): INTEGER;
VAR
BitSet1, BitSet2: BitSet;
TmpResult: integer;
buf: BitRange;
BEGIN {DateToInteger}
IF year > 1900 THEN
year := year - 1900;
IF year in [80 .. 199] THEN
year := year - 80
ELSE abort( 'Invalid year: ' + IntStr(year,0) );
IF not (month in [1..12]) THEN
abort( 'Invalid month: ' + IntStr(month,0) );
IF not (day in [1..31]) THEN
abort( 'Invalid day: ' + IntStr(day,0) );
IntegerToBitSet( 0, BitSet2 );
IntegerToBitSet( day, BitSet1 );
FOR buf := 0 to 15 DO
BEGIN
IF buf in BitSet1
THEN BitSet2 := BitSet2 + [buf];
END;
IntegerToBitSet( month, BitSet1 );
FOR buf := 0 to 15 DO
BEGIN
IF buf in BitSet1
THEN BitSet2 := BitSet2 + [buf + 5];
END;
IntegerToBitSet( year, BitSet1 );
FOR buf := 0 to 15 DO
BEGIN
IF buf in BitSet1
THEN BitSet2 := BitSet2 + [buf + 9];
END;
BitSetToInteger( BitSet2, TmpResult );
DateToInteger := TmpResult;
END; {DateToInteger}
PROCEDURE IntegerToTime( TheInteger: INTEGER;
VAR hours, minutes, seconds : INTEGER );
VAR
TheSet : BitSet;
BEGIN {IntegerToTime}
IntegerToBitSet( TheInteger, TheSet );
BitRangeToInt( TheSet, 11, 15, hours );
BitRangeToInt( TheSet, 5, 10, minutes );
BitRangeToInt( TheSet, 0, 4, seconds );
seconds := seconds * 2;
{We double seconds because the operating system stores
this value in two-second increments.}
END; {IntegerToTime}
FUNCTION TimeToInteger( hours,
minutes,
seconds: INTEGER ): INTEGER;
VAR
BitSet1, BitSet2: BitSet;
TmpResult: integer;
buf: BitRange;
BEGIN {TimeToInteger}
IF not (hours in [0..23]) THEN
abort( 'Invalid hour: ' + IntStr(hours,0) );
IF not( minutes in [0..59] ) THEN
abort( 'Invalid minute: ' + IntStr(minutes,0) );
IF not( seconds in [0..59] ) THEN
abort( 'Invalid second: ' + IntStr(seconds,0) );
IntegerToBitSet( 0, BitSet2 );
IntegerToBitSet( seconds div 2, BitSet1 );
FOR buf := 0 to 15 DO
BEGIN
IF buf in BitSet1
THEN BitSet2 := BitSet2 + [buf];
END;
IntegerToBitSet( minutes, BitSet1 );
FOR buf := 0 to 15 DO
BEGIN
IF buf in BitSet1
THEN BitSet2 := BitSet2 + [buf + 5];
END;
IntegerToBitSet( hours, BitSet1 );
FOR buf := 0 to 15 DO
BEGIN
IF buf in BitSet1
THEN BitSet2 := BitSet2 + [buf + 11];
END;
BitSetToInteger( BitSet2, TmpResult );
TimeToInteger := TmpResult;
END; {TimeToInteger}
PROCEDURE AddToFile( FileName : dos2str80; FileHandle : INTEGER;
message : dos2str255 );
VAR
SavedMessage : ErrorMessage;
AlreadyOpen : BOOLEAN;
BEGIN {AddToFile}
IF FileName = null
THEN abort( 'Always pass a file name to AddToFile.' );
IF FileHandle > 4 {see D-15 of PC-DOS manual}
THEN
BEGIN
AlreadyOpen := TRUE;
END
ELSE
BEGIN
AlreadyOpen := FALSE;
SavedMessage := OpenFile( FileHandle, FileName );
IF SavedMessage <> NoError
THEN printmessage( SavedMessage );
END;
SetPtrFromEnd( FileHandle, -1 );
{We move to -1 because we want to insert this data just
before the eof char.}
AddStr( message, #26 );
{This will be the new eof marker.}
WriteStr( FileHandle, message );
PrintMessage( CloseHandle( FileHandle ) );
{updates the file length}
IF AlreadyOpen
THEN
BEGIN
SavedMessage := OpenFile( FileHandle, FileName );
IF SavedMessage <> NoError
THEN printmessage( SavedMessage );
END;
END; {AddToFile}
PROCEDURE SetFileDateAndTime( FileHandle,
month, day, year,
hours, minutes, seconds: INTEGER );
VAR
rgstr : RegPack;
BEGIN {SetFileDateAndTime}
WITH rgstr DO
BEGIN
a.h := $57;
a.l := 1;
b.x := FileHandle;
d.x := DateToInteger( month, day, year );
c.x := TimeToInteger( hours, minutes, seconds );
{The reason for the swaps is that the bytes are reversed
when date and time values are passed in registers.}
msdos( rgstr );
IF FlaggedError( flags )
THEN PrintMessage( MessageType( a.x ) );
END; {WITH rgstr}
END; {SetFileDateAndTime}
PROCEDURE GetFileDateAndTime( FileHandle: INTEGER;
VAR month, day, year,
hours, minutes, seconds: INTEGER );
VAR
rgstr : RegPack;
BEGIN {GetFileDateAndTime}
WITH rgstr DO
BEGIN
a.h := $57;
a.l := 0;
b.x := FileHandle;
msdos( rgstr );
IF FlaggedError( flags ) THEN
PrintMessage( MessageType( a.x ) )
ELSE
BEGIN
IntegerToDate( d.x, month, day, year );
IntegerToTime( c.x, hours, minutes, seconds );
END;
END; {WITH rgstr}
END; {GetFileDateAndTime}
PROCEDURE LoadDTAinfo( VAR tmpstr : dos2str255 );
{Pulls information about files from an area of memory
called the Disk Transfer Address (DTA). Used in both
FindFirstFile and FindNextFile, below.}
PROCEDURE ExtractTime( TheInteger : INTEGER;
VAR TheStr : dos2str80 );
TYPE
str8 = STRING[8];
VAR
hours, minutes, seconds : INTEGER;
TheSet : BitSet;
MinStr : str8;
pm : BOOLEAN;
BEGIN {ExtractTime}
IntegerToTime( TheInteger, hours, minutes, seconds );
{From here down we're formatting TheStr so that the
string returned by LoadDTAinfo will look nice if it's
written.}
{
str( seconds:2, SecStr );
IF SecStr[1] = ' '
THEN SecStr[1] := '0';
You can add this back in if you're interested in the
seconds part of the file's time.
}
str( minutes:2, MinStr );
IF MinStr[1] = ' '
THEN MinStr[1] := '0';
pm := hours > 12;
IF pm
THEN hours := hours - 12;
TheStr := concat( ' ', IntStr(hours,2), ':', MinStr );
IF pm
THEN TheStr := concat( TheStr, 'p' )
ELSE TheStr := concat( TheStr, 'a' );
END; {ExtractTime}
PROCEDURE ExtractDate( TheInteger : INTEGER;
VAR TheStr : dos2str80 );
TYPE
str8 = STRING[8];
VAR
month, day, year : INTEGER;
TheSet : BitSet;
YrStr, MnthStr, DayStr : str8;
BEGIN {ExtractDate}
IntegerToDate( TheInteger, month, day, year );
str( day:2, DayStr );
IF DayStr[1] = ' '
THEN DayStr[1] := '0';
TheStr := concat( IntStr(month,2),
'-', DayStr,
'-', IntStr(year,2) );
END; {ExtractDate}
LABEL 1;
TYPE
str32 = STRING[32];
VAR
rgstr : RegPack;
FileSize : REAL;
DTAinfo : dos2str255;
SizeStr,
datestr,
timestr : str32;
SubDirCode,
cnt,
index : INTEGER;
LoWord, HiWord : INTEGER;
BEGIN {LoadDTAinfo}
SizeStr := null;
DateStr := null;
TimeStr := null;
WITH rgstr DO BEGIN
a.h := $2F; {get Disk Transfer Address}
msdos( rgstr );
{ES:BX now contains the DTA}
FillChar( DTAinfo, sizeof( DTAinfo ), CHR(0) );
FOR cnt := 0 TO 42 DO
mem[seg(DTAinfo):ofs(DTAinfo) + cnt] := mem[ES:b.x + cnt];
{Transfers 43 bytes from the DTA into DTAinfo.}
END; {WITH rgstr}
SubDirCode := ord(DTAinfo[21]) and $10;
{This sets SubDirCode to 16--that is, it turns on the
fourth bit of SubDirCode--if the file found is a
directory entry. Otherwise, SubDirCode is set to 0.}
IF SubDirCode <> 0 {That is, if the file is a sub-directory.}
THEN SizeStr := ' <DIR>'
ELSE
BEGIN
LoWord := BytesToWord( ORD(DTAinfo[26]), ORD(DTAinfo[27]) );
HiWord := BytesToWord( ORD(DTAinfo[28]), ORD(DTAinfo[29]) );
FileSize := SegmentedToReal( HiWord, LoWord );
str( FileSize:0:0, SizeStr );
WHILE length(SizeStr) < 8
DO insert( ' ', SizeStr, 1 );
END;
ExtractTime( BytesToWord( ORD(DTAinfo[22]), ORD(DTAinfo[23]) ),
timestr );
ExtractDate( BytesToWord( ORD(DTAinfo[24]), ORD(DTAinfo[25]) ),
datestr );
WHILE length(DateStr) < 10
DO insert( ' ', DateStr, 1 );
tmpstr := null;
FOR index := 30 TO 43 DO
BEGIN
tmpstr[0] := succ( tmpstr[0] );
IF DTAinfo[ index ] = CHR(0)
THEN
BEGIN
tmpstr[0] := pred( tmpstr[0] );
GOTO 1;
END
ELSE tmpstr[ index - 29 ] := DTAinfo[ index ];
END;
1:
WHILE length(TmpStr) < 12
DO TmpStr := concat( TmpStr, ' ' );
TmpStr := concat( TmpStr, SizeStr, datestr, timestr );
END; {LoadDTAinfo}
TYPE
DTAptr = ^DTA;
DTA = array [1..128] of byte;
VAR
DTAseg, DTAofs : INTEGER;
TmpDTAptr : DTAptr;
PROCEDURE SaveDTA;
VAR
rgstr : RegPack;
BEGIN {SaveDTA}
WITH rgstr DO BEGIN
a.h := $2F;
msdos( rgstr );
DTAseg := es;
DTAofs := b.x;
new( TmpDTAptr );
ds := seg( TmpDTAptr^ );
d.x := ofs( TmpDTAptr^ );
a.h := $1A;
END; {WITH rgstr}
msdos( rgstr );
END; {SaveDTA}
PROCEDURE RestoreDTA;
VAR
rgstr : RegPack;
BEGIN {RestoreDTA}
dispose( TmpDTAptr );
rgstr.ds := DTAseg;
rgstr.d.x := DTAofs;
rgstr.a.h := $1A;
msdos( rgstr );
END; {RestoreDTA}
FUNCTION FindFirstFile(FileName: dos2str80;
VAR FileInfo: dos2str255): ErrorMessage;
VAR
tmpset : BitSet;
rgstr : RegPack;
tmpstr : dos2str80;
BEGIN {FindFirstFile}
FindFirstFile := NoError;
FileInfo := null;
tmpstr := FileName;
MakeAsciiZ( tmpstr );
WITH rgstr DO BEGIN
d.x := ofs( tmpstr );
ds := seg( tmpstr );
TmpSet := [0,1,2,4];
{We set four attribute bits: read-only file, hidden
file, system file, and sub-directory. This allows us to
find any of these files, plus normal files.}
BitSetToInteger( TmpSet, c.x );
a.h := $4E; {find first matching file}
msdos( rgstr );
IF FlaggedError( flags )
THEN FindFirstFile := MessageType( a.x )
ELSE LoadDTAinfo( FileInfo );
END; {WITH rgstr}
END; {FindFirstFile}
FUNCTION FindNextFile( VAR FileInfo : dos2str255 ): ErrorMessage;
VAR
rgstr : RegPack;
BEGIN
FindNextFile := NoError;
FileInfo := null;
WITH rgstr DO BEGIN
a.h := $4F; {find next matching file}
flags := 0;
msdos( rgstr );
IF FlaggedError( flags )
THEN FindNextFile := MessageType( a.x )
ELSE LoadDTAinfo( FileInfo );
END; {WITH rgstr}
END; {FindNextFile}
FUNCTION VolumeLabel( TheDrive: CHAR ): dos2str80;
{Returns the label of the disk in TheDrive.}
VAR
rgstr : RegPack;
XFCB : RECORD
prfx : array [1..7] of byte;
fcb : array [0..36] of byte;
END;
{XFCB is an "Extended File Control Block." }
bufstr : dos2str80;
cnt : INTEGER;
BEGIN {VolumeLabel}
lowerch( TheDrive );
bufstr := null;
fillchar( XFCB, sizeof(XFCB), '?' );
{We fill XFCB with question marks because function $11
does not take any other kind of wildcard. The PC-DOS
documentation says that question-mark wildcards are
allowed, but neglects to mention that they are
mandatory.}
WITH XFCB DO
BEGIN
prfx[1] := $FF; {indicates an extended FCB}
prfx[7] := $8; {attribute set to volume label}
IF TheDrive = 'z'
THEN fcb[0] := 0
ELSE fcb[0] := ord(TheDrive) - 96 ;
{sets 'a' to 1, 'b' to 2, etc.}
END;
WITH rgstr DO BEGIN
ds := seg( XFCB );
d.x := ofs( XFCB );
a.h := $11; {Search for first entry.}
msdos( rgstr );
IF a.l = $FF
THEN bufstr := 'unlabelled vol'
ELSE
BEGIN
a.h := $2F; {get Disk Transfer Address}
msdos( rgstr );
{ES:BX now contains the DTA}
FOR cnt := 8 to 18 DO
AddStr( bufstr, chr(mem[es:b.x + cnt]) );
{We do this because information from the search gets
transferred into the DTA, not the extended file control
block whose address we passed going into function $11.}
END;
END; {WITH rgstr}
VolumeLabel := bufstr;
END; {VolumeLabel}
FUNCTION FreeDiskSpace( DriveLetter: CHAR;
VAR FreeBytes: REAL ): ErrorMessage;
CONST
upperdifference = 32;
VAR
rgstr : RegPack;
BEGIN
FreeDiskSpace := NoError;
FreeBytes := 0;
lowerch( DriveLetter );
IF not (DriveLetter in ['a'..'z'])
THEN halt;
WITH rgstr DO BEGIN
IF DriveLetter = 'z' {'z' means default drive}
THEN d.l := 0
ELSE d.l := ord( DriveLetter ) - 96;
{turns an A into a 1, etc}
a.h := $36;
msdos( rgstr );
IF a.x = $FFFF THEN
FreeDiskSpace := InvalidDrive
{AX returns $FFFF if the drive number was invalid.
Otherwise, BX contains the number of available clusters,
DX contains the total number of bytes per sector, and AX
contains the number of sectors per cluster.}
ELSE
BEGIN
FreeBytes := WordToReal(b.x) * WordToReal(a.x);
FreeBytes := FreeBytes * WordToReal(c.x);
{Division of this operation into two lines only reduces
the width of the listing.}
END;
END; {WITH rgstr}
END; {FreeDiskSpace}
FUNCTION CopyFile( OldHandle: integer;
NewFileName: dos2str80 ): ErrorMessage;
TYPE
memptr = RECORD
addr : ^integer;
size : INTEGER;
END;
VAR
TheDrive : char;
MemoryPtr : memptr;
NewHandle : INTEGER;
SavedMessage : ErrorMessage;
FreeBytes,
FileSize,
BytesToBeFreed,
BytesToRead : REAL;
PROCEDURE ReadOldFile( VAR MemoryPtr : memptr );
LABEL EndProcedure;
VAR
rgstr : regpack;
function min( first, second: real ): real;
begin {min}
if first < second
then min := first
else min := second;
end; {min}
BEGIN {ReadOldFile}
IF BytesToRead <= 0 THEN
BEGIN
MemoryPtr.addr := nil;
GOTO EndProcedure;
END;
with MemoryPtr DO
BEGIN
size := RealToWord( min( maxavail * 16,
min( SegSize - 1,
BytesToRead)));
GetMem( addr, size );
rgstr.c.x := size;
{CX gets number of bytes to read.}
rgstr.a.h := $3F; {DOS Read From file Code}
rgstr.b.x := OldHandle;
rgstr.d.x := ofs( addr^ );
rgstr.ds := seg( addr^ );
END;
msdos( rgstr );
IF FlaggedError( rgstr.flags )
THEN printmessage( messagetype( rgstr.a.x ) )
ELSE BytesToRead := BytesToRead - MemoryPtr.size;
EndProcedure:
END; {ReadOldFile}
PROCEDURE WriteNewFile( MemoryPtr : MemPtr );
LABEL EndProcedure;
VAR
rgstr : regpack;
BEGIN {WriteNewFile}
IF MemoryPtr.addr = nil
THEN GOTO EndProcedure;
rgstr.b.x := NewHandle;
rgstr.c.x := MemoryPtr.size;
rgstr.ds := seg( MemoryPtr.addr^ );
rgstr.d.x := ofs( MemoryPtr.addr^ );
rgstr.a.h := $40; {Write to a file or device.}
msdos( rgstr );
IF rgstr.a.x < rgstr.c.x
{if fewer than c.x bytes were actually written}
THEN
BEGIN
CopyFile := AccessDenied;
SavedMessage := CloseHandle( NewHandle );
WriteStr( outp, 'No room.' );
halt;
END;
FreeMem( MemoryPtr.addr, MemoryPtr.size );
EndProcedure:
END; {WriteNewFile}
PROCEDURE SetDateAndTime;
VAR
month, day, year,
hours, minutes, seconds : INTEGER;
BEGIN
GetFileDateAndTime(OldHandle, month, day, year,
hours, minutes, seconds );
SetFileDateAndTime(NewHandle, month, day, year,
hours, minutes, seconds );
END; {SetDateAndTime}
LABEL
EndProcedure;
begin {CopyFile}
BytesToBeFreed := 0;
CopyFile := NoError;
FileSize := FileLength( OldHandle );
BytesToRead := FileSize;
IF pos(':', NewFileName) = 2 THEN
TheDrive := NewFileName[1]
ELSE TheDrive := 'z';
{Determines the drive to which we're copying.
'z' means "default drive" to FreeDiskSpace.}
SavedMessage := FreeDiskSpace( TheDrive, FreeBytes );
if SavedMessage <> NoError then
goto EndProcedure;
SavedMessage := OpenFile( NewHandle, NewFileName );
if SavedMessage = NoError then
begin
BytesToBeFreed := FileLength( NewHandle );
SavedMessage := CloseHandle( NewHandle );
end
else
begin
if SavedMessage <> FileNotFound then
goto EndProcedure;
end;
IF FileSize > (FreeBytes + BytesToBeFreed) THEN
BEGIN
SavedMessage := AccessDenied;
{This will have to stand for 'Not enough room.'}
goto EndProcedure;
END;
SavedMessage := CreateFile(NewHandle, NewFileName);
if SavedMessage <> NoError then
goto EndProcedure;
REPEAT
ReadOldFile( MemoryPtr );
WriteNewFile( MemoryPtr );
UNTIL (BytesToRead <= 0);
SetDateAndTime;
SavedMessage := CloseHandle(NewHandle);
EndProcedure:
CopyFile := SavedMessage;
end; {CopyFile}